home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / akcl / kcl.lha / lsp / evalmacros.lsp < prev    next >
Lisp/Scheme  |  1987-06-04  |  9KB  |  272 lines
  1. ;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  2. ;; Copying of this file is authorized to users who have executed the true and
  3. ;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  4.  
  5. ;;;;    evalmacros.lsp
  6.  
  7.  
  8. (in-package 'lisp)
  9.  
  10. (export '(defvar defparameter defconstant))
  11.  
  12. (in-package 'system)
  13.  
  14.  
  15. (eval-when (compile) (proclaim '(optimize (safety 2) (space 3))))
  16. (eval-when (eval compile) (defun si:clear-compiler-properties (symbol)))
  17. (eval-when (eval compile) (setq si:*inhibit-macro-special* nil))
  18.  
  19. (defmacro defvar (var &optional (form nil form-sp) doc-string)
  20.   (if form-sp
  21.       (if doc-string
  22.           `(progn (si:*make-special ',var)
  23.                   (si:putprop ',var ,doc-string 'variable-documentation)
  24.                   (unless (boundp ',var)
  25.                           (setq ,var ,form))
  26.                   ',var)
  27.           `(progn (si:*make-special ',var)
  28.                   (unless (boundp ',var)
  29.                           (setq ,var ,form))
  30.                   ',var))
  31.       `(progn (si:*make-special ',var)
  32.               ',var)))
  33.  
  34. (defmacro defparameter (var form &optional doc-string)
  35.   (if doc-string
  36.       `(progn (si:*make-special ',var)
  37.               (si:putprop ',var ,doc-string 'variable-documentation)
  38.               (setq ,var ,form)
  39.               ',var)
  40.       `(progn (si:*make-special ',var)
  41.               (setq ,var ,form)
  42.               ',var)))
  43.  
  44. (defmacro defconstant (var form &optional doc-string)
  45.   (if doc-string
  46.       `(progn (si:*make-constant ',var ,form)
  47.               (si:putprop ',var ,doc-string 'variable-documentation)
  48.               ',var)
  49.       `(progn (si:*make-constant ',var ,form)
  50.               ',var)))
  51.  
  52.  
  53. ;;; Each of the following macros is also defined as a special form.
  54. ;;; Thus their names need not be exported.
  55.  
  56. (defmacro and (&rest forms)
  57.   (if (endp forms)
  58.       t
  59.       (let ((x (reverse forms)))
  60.            (do ((forms (cdr x) (cdr forms))
  61.                 (form (car x) `(if ,(car forms) ,form)))
  62.                ((endp forms) form))))
  63.   )
  64.  
  65. (defmacro or (&rest forms)
  66.   (if (endp forms)
  67.       nil
  68.       (let ((x (reverse forms)))
  69.            (do ((forms (cdr x) (cdr forms))
  70.                 (form (car x)
  71.                       (let ((temp (gensym)))
  72.                            `(let ((,temp ,(car forms)))
  73.                                  (if ,temp ,temp ,form)))))
  74.                ((endp forms) form))))
  75.   )
  76.                
  77. (defmacro locally (&rest body) `(let () ,@body))
  78.  
  79. (defmacro loop (&rest body &aux (tag (gensym)))
  80.   `(block nil (tagbody ,tag (progn ,@body) (go ,tag))))
  81.  
  82. (defmacro defmacro (name vl &rest body)
  83.   `(si:define-macro ',name (si:defmacro* ',name ',vl ',body)))
  84.  
  85. (defmacro defun (name lambda-list &rest body)
  86.   (multiple-value-bind (doc decl body)
  87.        (find-doc body nil)
  88.     (if doc
  89.         `(progn (setf (get ',name 'si:function-documentation) ,doc)
  90.                 (setf (symbol-function ',name)
  91.                       #'(lambda ,lambda-list
  92.                           ,@decl (block ,name ,@body)))
  93.                 ',name)
  94.         `(progn (setf (symbol-function ',name)
  95.                       #'(lambda ,lambda-list
  96.                           ,@decl (block ,name ,@body)))
  97.                 ',name))))
  98.  
  99. ; assignment
  100.  
  101. (defmacro psetq (&rest args)
  102.    (do ((l args (cddr l))
  103.         (forms nil)
  104.         (bindings nil))
  105.        ((endp l) (list* 'let* (reverse bindings) (reverse (cons nil forms))))
  106.        (declare (object l))
  107.        (let ((sym (gensym)))
  108.             (push (list sym (cadr l)) bindings)
  109.             (push (list 'setq (car l) sym) forms)))
  110.    )
  111.  
  112. ; conditionals
  113.  
  114. (defmacro cond (&rest clauses &aux (form nil))
  115.   (dolist (l (reverse clauses) form)
  116.           (declare (object l))
  117.     (cond ((endp (cdr l))
  118.            (if (eq (car l) 't)
  119.                (setq form 't)
  120.                (let ((sym (gensym)))
  121.                     (setq form `(let ((,sym ,(car l)))
  122.                                      (if ,sym ,sym ,form))))))
  123.           ((eq (car l) 't)
  124.            (setq form (if (endp (cddr l))
  125.                           (cadr l)
  126.                           `(progn ,@(cdr l)))))
  127.           (t (setq form (if (endp (cddr l))
  128.                             `(if ,(car l) ,(cadr l) ,form)
  129.                             `(if ,(car l) (progn ,@(cdr l)) ,form))))))
  130.   )
  131.  
  132. (defmacro when (pred &rest body)
  133.   `(if ,pred (progn ,@body)))
  134.  
  135. (defmacro unless (pred &rest body)
  136.   `(if (not ,pred) (progn ,@body)))
  137.  
  138. ; program feature
  139.  
  140. (defmacro prog (vl &rest body &aux (decl nil))
  141.   (do ()
  142.       ((or (endp body)
  143.            (not (consp (car body)))
  144.            (not (eq (caar body) 'declare)))
  145.        `(block nil (let ,vl ,@decl (tagbody ,@body)))
  146.        )
  147.       (push (car body) decl)
  148.       (pop body))
  149.   )
  150.  
  151. (defmacro prog* (vl &rest body &aux (decl nil))
  152.   (do ()
  153.       ((or (endp body)
  154.            (not (consp (car body)))
  155.            (not (eq (caar body) 'declare)))
  156.        `(block nil (let* ,vl ,@decl (tagbody ,@body)))
  157.        )
  158.       (push (car body) decl)
  159.       (pop body))
  160.   )
  161.  
  162. ; sequencing
  163.  
  164. (defmacro prog1 (first &rest body &aux (sym (gensym)))
  165.   `(let ((,sym ,first)) ,@body ,sym))
  166.  
  167. (defmacro prog2 (first second &rest body &aux (sym (gensym)))
  168.   `(progn ,first (let ((,sym ,second)) ,@body ,sym)))
  169.  
  170. ; multiple values
  171.  
  172. (defmacro multiple-value-list (form)
  173.   `(multiple-value-call 'list ,form))
  174.  
  175. (defmacro multiple-value-setq (vars form)
  176.   (do ((vl vars (cdr vl))
  177.        (sym (gensym))
  178.        (forms nil)
  179.        (n 0 (1+ n)))
  180.       ((endp vl) `(let ((,sym (multiple-value-list ,form))) ,@forms))
  181.       (declare (fixnum n) (object vl))
  182.       (push `(setq ,(car vl) (nth ,n ,sym)) forms))
  183.   )
  184.  
  185. (defmacro multiple-value-bind (vars form &rest body)
  186.   (do ((vl vars (cdr vl))
  187.        (sym (gensym))
  188.        (bind nil)
  189.        (n 0 (1+ n)))
  190.       ((endp vl) `(let* ((,sym (multiple-value-list ,form)) ,@(reverse bind))
  191.                         ,@body))
  192.       (declare (fixnum n) (object vl))
  193.       (push `(,(car vl) (nth ,n ,sym)) bind))
  194.   )
  195.  
  196. (defmacro do (control (test . result) &rest body
  197.               &aux (decl nil) (label (gensym)) (vl nil) (step nil))
  198.   (do ()
  199.       ((or (endp body)
  200.            (not (consp (car body)))
  201.            (not (eq (caar body) 'declare))))
  202.       (push (car body) decl)
  203.       (pop body))
  204.   (dolist (c control)
  205.           (declare (object c))
  206.     (push (list (car c) (cadr c)) vl)
  207.     (unless (endp (cddr c))
  208.             (push (car c) step)
  209.             (push (caddr c) step)))
  210.   `(block nil
  211.           (let ,(reverse vl)
  212.                ,@decl
  213.                (tagbody
  214.                 ,label (if ,test (return (progn ,@result)))
  215.                        (tagbody ,@body)
  216.                        (psetq ,@(reverse step))
  217.                        (go ,label)))))
  218.  
  219. (defmacro do* (control (test . result) &rest body
  220.                &aux (decl nil) (label (gensym)) (vl nil) (step nil))
  221.   (do ()
  222.       ((or (endp body)
  223.            (not (consp (car body)))
  224.            (not (eq (caar body) 'declare))))
  225.       (push (car body) decl)
  226.       (pop body))
  227.   (dolist (c control)
  228.           (declare (object c))
  229.     (push (list (car c) (cadr c)) vl)
  230.     (unless (endp (cddr c))
  231.             (push (car c) step)
  232.             (push (caddr c) step)))
  233.   `(block nil
  234.           (let* ,(reverse vl)
  235.                 ,@decl
  236.                 (tagbody
  237.                  ,label (if ,test (return (progn ,@result)))
  238.                         (tagbody ,@body)
  239.                         (setq ,@(reverse step))
  240.                         (go ,label))))
  241.   )
  242.  
  243. (defmacro case (keyform &rest clauses &aux (form nil) (key (gensym)))
  244.   (dolist (clause (reverse clauses) `(let ((,key ,keyform)) ,form))
  245.           (declare (object clause))
  246.     (cond ((or (eq (car clause) 't) (eq (car clause) 'otherwise))
  247.            (setq form `(progn ,@(cdr clause))))
  248.           ((consp (car clause))
  249.            (setq form `(if (member ,key ',(car clause))
  250.                            (progn ,@(cdr clause))
  251.                            ,form)))
  252.           ((car clause)
  253.            (setq form `(if (eql ,key ',(car clause))
  254.                            (progn ,@(cdr clause))
  255.                            ,form)))))
  256.   )
  257.  
  258.  
  259. (defmacro return (&optional (val nil)) `(return-from nil ,val))
  260.  
  261. (defmacro dolist ((var form &optional (val nil)) &rest body
  262.                                                  &aux (temp (gensym)))
  263.   `(do* ((,temp ,form (cdr ,temp)) (,var (car ,temp) (car ,temp)))
  264.     ((endp ,temp) ,val)
  265.     ,@body))
  266.  
  267. (defmacro dotimes ((var form &optional (val nil)) &rest body
  268.                                                   &aux (temp (gensym)))
  269.   `(do* ((,temp ,form) (,var 0 (1+ ,var)))
  270.         ((>= ,var ,temp) ,val)
  271.         ,@body))
  272.